home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Franz PD / Franz PD Disk #102 (1990-12)(Amiga User Group Deutschland e.V.).zip / Franz PD Disk #102 (1990-12)(Amiga User Group Deutschland e.V.).adf / Raumgestaltung / Kuechenzeile_Drucken (.txt) < prev    next >
AmigaBASIC Source Code  |  1989-07-03  |  11KB  |  401 lines
  1.  
  2. SCREEN 2,320,250,5,1
  3. WINDOW 2,"             Küchenzeile ",,0,2
  4.   PALETTE 29,0,0,0      
  5.   PALETTE 1,0.8,0,0     
  6.   PALETTE 2,1,0,0      
  7.   PALETTE 3,0.93,0.2,0   
  8.   PALETTE 4,1,0.4,0     
  9.   PALETTE 5,1,0.6,0     
  10.   PALETTE 6,1,0.8,0     
  11.   PALETTE 7,1,1,0     
  12.   PALETTE 8,0.6,1,0.15   
  13.   PALETTE 9,0.5,0.8,0.15  
  14.   PALETTE 10,0.4,0.6,0   
  15.   PALETTE 11,0.2,0.4,0   
  16.   PALETTE 12,0,0.4,0    
  17.   PALETTE 13,0,0.6,0.67  
  18.   PALETTE 14,0,0.8,0.6   
  19.   PALETTE 15,0,1,0.6   
  20.   PALETTE 16,0.2,1,0.93  
  21.   PALETTE 17,0.2,0.75,1  
  22.   PALETTE 18,0.15,0.4,1  
  23.   PALETTE 19,0.4,0,1    
  24.   PALETTE 20,0,0,0.6    
  25.   PALETTE 21,0.35,0.15,0.8
  26.   PALETTE 22,0.6,0.2,1   
  27.   PALETTE 23,1,0,1     
  28.   PALETTE 24,0.9,0.5,0.75 
  29.   PALETTE 25,1,0.75,0.75 
  30.   PALETTE 26,0.8,0.55,0.5 
  31.   PALETTE 27,0.6,0.4,0.35 
  32.   PALETTE 28,0.4,0.2,0.2   
  33.   PALETTE 0,0.6,0.6,0.6  
  34.   PALETTE 30,0.6,0.6,0.6   
  35.   PALETTE 31,0.7,0.7,0.7    
  36.    CLEAR ,30000                
  37.    DIM bau(110,20)  
  38.    w=1:mx=-1:my=0
  39.    FOR ein=1 TO 20
  40. ON ein GOSUB radier,fenstero,fensteru,fensterl,fensterr,kreuz,vierb,tisch,stuhlk,kasten,stuhl,balkeno,balkenu,links,rechts,eckelu,eckero,eckeol,eckeur,tischgr
  41.    GET(0,0)-(19,19),bau(110,ein-1)
  42.    CLS               
  43.    NEXT
  44.    GOSUB Rahmen : GOSUB bauen   
  45. retur:
  46.    MENU ON
  47.    WHILE MOUSE(0) = 0
  48.    x = MOUSE(1): y = MOUSE(2)
  49.    IF y<180 THEN
  50.    PUT(x-10,y-5),bau(110,w)
  51.    PUT(x-10,y-5),bau(110,w)
  52.    END IF
  53.    WEND       
  54.    IF x> = 300 THEN retur                
  55.    IF y> = 180 THEN GOTO taste
  56. kleber:                             
  57.    x = FIX (x/20): y = FIX(y/20)
  58.    x = x*20: y = y*20
  59.    IF w = 19 AND mx<>-1 THEN PUT(mx,my),bau(110,19)
  60.    IF x = mx AND y = my THEN mx = -1
  61.    IF w<19 THEN PUT(x,y),bau(110,w),PSET :ELSE PUT(x,y),bau(110,19)
  62.    mx = x: my = y
  63.    GOTO retur 
  64. taste:                           
  65.    rx = MOUSE(1)
  66.    rx = FIX(rx/20): y = FIX(y/20): y = y*20
  67.    IF y = 180 THEN w = rx
  68.    IF y = 200 AND rx<5 THEN w = 15+rx 
  69.    IF y = 200 AND rx> = 5 THEN druecke
  70.    a = MOUSE(0) 
  71.    GOTO retur
  72. '**************************
  73. druecke:
  74.     rx = MOUSE(1)
  75.     IF rx <160 AND rx >120 THEN sauber
  76.     IF rx <220 AND rx >180 THEN GOSUB ScreenDump
  77.     IF rx <280 AND rx >240 THEN GOTO ende    
  78. sauber:
  79.     LINE (20,50)-(280,178),0,bf
  80.        FOR r = 20 TO 275  STEP 5
  81.     FOR c = 120 TO 135 STEP 5
  82.     LINE (r,c)-(r+5,c+5),27,b
  83.    NEXT c
  84.    NEXT r     
  85.  
  86.     GOTO retur
  87. bauen:
  88.   FOR a = 0 TO 14 
  89.   x = a*20
  90.   PUT (x,182), bau(110,a),PSET
  91.   NEXT
  92.   FOR a = 15 TO 19
  93.   x =  a*20-300
  94.   PUT (x,202), bau(110,a),PSET
  95.   NEXT
  96.       CIRCLE (140,220),20,16,,,0.5:PAINT(140,220),16
  97.       CALL tool (125,220):COLOR 7,16:LOCATE 28,17:PRINT "NEU"
  98.       CIRCLE (204,220),22,16,,,0.5 :PAINT(200,220),16
  99.       CALL tool (185,220):COLOR 7,16:LOCATE 28,24:PRINT "DRUCK"
  100.       CIRCLE (270,220),22,16,,,0.5:PAINT (270,220),16
  101.       CALL tool (265,220):COLOR 7,16:LOCATE 28,33:PRINT "ENDE"
  102.   RETURN 
  103. Rahmen:
  104.    l=1:h=1
  105.    COLOR 20,0
  106.    LOCATE 7,1:PRINT "Geben Sie bitte die Zeilenlänge ein."
  107.    LOCATE 9,12:  INPUT"Länge  m ";l            ' Länge
  108.    CLS
  109.    IF l< 11 THEN a = 282
  110.    IF h<  9 THEN b = 180
  111.    LINE(18,48)-(a,b),21,b             
  112.    LINE(19,49)-(a-1,b-1),21,b
  113.     
  114. Fliesen:   
  115.    FOR r = 20 TO 275  STEP 5
  116.     FOR c = 120 TO 135 STEP 5
  117.     LINE (r,c)-(r+5,c+5),27,b
  118.    NEXT c
  119.    NEXT r     
  120.    e=48 :f=18
  121.    FOR x = 18 TO a STEP (a-18)/l         
  122.    LINE (x,e-5) - (x,e+1),2
  123.    NEXT x   
  124.    FOR y = 48 TO b STEP (b-48)/h         
  125.    LINE (f-5,y) - (f+1,y),2
  126.    NEXT y
  127.    COLOR 20,0:LOCATE 6,35:PRINT l 
  128.    SUB tool(c%,d%) STATIC
  129.    xa&=WINDOW(8)+36:ya&=WINDOW(8)+38
  130.    POKEW xa&,c%
  131.    POKEW ya&,d%
  132.    END SUB
  133.  
  134. radier:
  135.    LINE (0,0)-(20,20),0,bf                    ' 1
  136.    RETURN
  137.  
  138. fenstero:
  139.    LINE (0,10)-(19,19),28,bf
  140.    LINE (0,0)-(0,19),28
  141.    LINE (19,0)-(19,19),28
  142.    CIRCLE (10,15),1,7,,,1:PAINT(10,15),7     '2
  143.    RETURN
  144. fensteru:
  145.    LINE (0,0)-(19,10),28,bf
  146.    LINE (0,0)-(0,19),28
  147.    LINE (19,0)-(19,19),28
  148.    CIRCLE (10,5),1,7,,,1:PAINT(10,5),7        ' 3
  149.    RETURN
  150. fensterl:
  151.    LINE (1,1)-(19,10),28,bf
  152.    LINE (1,10)-(19,19),28,bf
  153.    LINE (0,10)-(19,10),0
  154.    CIRCLE (10,15),1,7,,,1:PAINT(10,15),7
  155.    CIRCLE (10,5),1,7,,,1:PAINT(10,5),7           '4
  156.    RETURN
  157. fensterr:
  158.   LINE (0,0)-(19,19),28,b
  159.   CIRCLE (5,10),1.5,28,,,1:PAINT(5,10),28             ' 5
  160.   RETURN
  161.  
  162. kreuz:
  163.    LINE (0,0)-(19,19),28,b
  164.    CIRCLE (15,10),1.5,28,,,1:PAINT(15,10),28          ' 6        
  165.    RETURN
  166.  
  167. stuhl:
  168.   LINE (0,0)-(19,0),28
  169.   LINE (0,0)-(0,19),28
  170.   LINE (19,0)-(19,19),28
  171.   CIRCLE (5,10),1.5,28,,,1:PAINT(5,10),28             ' 7
  172.   RETURN
  173.  
  174. vierb:
  175.   LINE (0,0)-(19,19),28,b
  176.   LINE (0,0)-(19,0),0
  177.   CIRCLE (5,10),1.5,28,,,1   :PAINT(5,10),28       ' 8      
  178.   RETURN
  179.  
  180. tisch:
  181.   LINE (0,0)-(19,19),28,b                             ' 9
  182.   RETURN
  183.  
  184. stuhlk:
  185.   LINE (0,0)-(19,0),28
  186.   LINE (0,0)-(0,19),28
  187.   LINE (19,0)-(19,19),28
  188.   LINE (0,6)-(19,6),28
  189.   CIRCLE (14,3),1,28:CIRCLE (17,3),1,28
  190.   CIRCLE (10,19),6,28,,,1:PAINT(10,19),28             ' 10  wasch
  191. RETURN
  192.  
  193. kasten:
  194.   LINE (0,0)-(19,19),28,b
  195.   LINE (0,0)-(19,0),0                                 ' 11 wasch
  196.   LINE (0,14)-(19,14),28
  197.   CIRCLE (10,0),6,28,,,1:PAINT(10,0),28
  198.   RETURN
  199.  
  200. balkeno:
  201.   LINE (1,0)-(19,19),28,bf
  202.   CIRCLE (5,10),1.5,7,,,1:PAINT(5,10),7               ' 12
  203.   RETURN
  204. balkenu:
  205.   LINE (0,15)-(19,19),28,bf                           ' 13
  206.   RETURN
  207.  
  208. rechts:
  209.   LINE (0,0)-(0,19),28                                ' 14
  210.   LINE (19,0)-(19,19),28
  211.   RETURN
  212.  
  213. links:
  214.   LINE (1,0)-(19,19),28,bf                           ' 15
  215.   RETURN
  216.  
  217.  
  218. eckelu:
  219.    LINE (0,0)-(19,10),28,bf                            ' 16 Herd
  220.    LINE (0,0)-(4,19),28,bf
  221.    LINE (15,0)-(19,19),28,bf
  222.    CIRCLE (13,3),1,7:CIRCLE (16,3),1,7
  223.    CIRCLE (4,3),1,7:CIRCLE (7,3),1,7
  224.    RETURN
  225.  
  226. eckero:
  227.    LINE (0,5)-(19,19),28,bf
  228.    LINE (0,0)-(4,19),28,bf
  229.    LINE (15,0)-(19,19),28,bf
  230.    CIRCLE (10,15),1,7,,,1:PAINT(10,15),7                ' 17 Herd
  231. RETURN
  232. eckeol:
  233. LINE (1,0)-(19,19),28,bf
  234. CIRCLE (15,10),1.5,7,,,1 :PAINT (15,10),7
  235. RETURN
  236.  
  237. eckeur:
  238. LINE (0,1)-(19,19),28,bf
  239. CIRCLE (10,17),1,7,,,1:PAINT(10,17),7
  240. RETURN
  241.  
  242.  
  243. tischgr:
  244. CIRCLE (10,10),8,0,,,1:PAINT(10,10),0
  245. RETURN
  246.  
  247.  
  248.  
  249. ScreenDump:
  250. LINE (0,182)-(300,248),0,bf
  251. REM  Beim ersten Aufruf dieser Routine
  252. REM   sind die Funktionen aus der Exec-Library
  253. REM   mit Ergebniswerten zu deklarieren:
  254.  
  255. IF AlreadyDeclared = 0 THEN
  256.  DECLARE FUNCTION AllocSignal%() LIBRARY
  257.  DECLARE FUNCTION AllocMem&()    LIBRARY
  258.  DECLARE FUNCTION FindTask&()    LIBRARY
  259.  DECLARE FUNCTION DoIO&()        LIBRARY
  260.  DECLARE FUNCTION OpenDevice&    LIBRARY
  261.  AlreadyDeclared = 1
  262. END IF
  263.  
  264. REM  Adressen der div. Structures ermitteln
  265.  
  266. sWindow&   = WINDOW(7)
  267. sScreen&   = PEEKL(sWindow& + 46)
  268. sViewPort& = sScreen& + 44
  269. sRastPort& = sScreen& + 84
  270. sColorMap& = PEEKL(sViewPort& + 4)
  271.  
  272. REM  Screen-Breite, -Höhe und Modus-Flags 
  273.  
  274. maxWidth%  = PEEKW(sScreen& + 12)
  275. maxHeight% = PEEKW(sScreen& + 14)
  276. viewModes% = PEEKW(sViewPort& + 32)
  277.  
  278. REM Parameter fuer Druckbefehl aufstellen
  279.  
  280. command%  = 11   'Drucker-Befehls-Nummer
  281. srcX% = 0        'Sende ganzen Screen
  282. srcY% = 0 
  283. srcWidth%  = maxWidth%
  284. srcHeight% = maxHeight%
  285. destRows& = 0    
  286. destCols& = 0
  287. special% = &H84  'FullCol | Aspect
  288.  
  289. IF BorderFlag% = 0 THEN  'Kein Rahmen
  290.    srcX% = srcX% + 3
  291.    srcY% = srcY% + 11
  292.    srcWidth%  = srcWidth% - 3 - 11
  293.    srcHeight% = srcHeight% - 11 - 3
  294. END IF   
  295.  
  296. LIBRARY "exec.library"
  297.  
  298.  
  299. REM *** CreatePort ***
  300.  
  301. sigBit% =  AllocSignal%(-1)
  302. ClearPublic& = 65537
  303. msgPort& = AllocMem&(40,ClearPublic&)
  304. IF msgPort& = 0 THEN
  305.    PRINT "msgPort nicht allokierbar."
  306.    GOTO cleanup4
  307. END IF
  308.  
  309.  
  310. POKE(msgPort& + 8), 4 'Type=NT_MSGPORT
  311. POKE(msgPort& + 9), 0 'Priority 0 
  312. portName$ = "MyPrtPort"+CHR$(0)
  313. POKEL(msgPort& + 10), SADD(portName$)
  314. POKE(msgPort& + 14), 0 'Flags
  315. POKE(msgPort& + 15), sigBit%
  316. sigTask& = FindTask&(0)
  317. POKEL(msgPort& + 16), sigTask&
  318.  
  319. CALL AddPort(msgPort&)  'Port hinzufuegen
  320.  
  321.  
  322. REM  *** CreatExtIO ***
  323.  
  324. ioRequest& = AllocMem&(64,ClearPublic&)
  325. IF ioRequest& = 0  THEN
  326.    PRINT "ioRequest nicht allokierbar."
  327.    GOTO cleanup3
  328. END IF
  329.  
  330. POKE(ioRequest& + 8),5 'Type=NT_MESSAGE
  331. POKE(ioRequest& + 9),0 'Priority 0
  332. POKEL(ioRequest& + 14), msgPort&
  333.  
  334.  
  335. REM  *** Open  Printer Device ***
  336.  
  337. devName$ = "printer.device"+CHR$(0)
  338. pError& = OpenDevice&(SADD(devName$),0,ioRequest&,0)
  339. IF pError& <> 0  THEN
  340.    PRINT "Drucker nicht ansprechbar."
  341.    GOTO cleanup2
  342. END IF
  343.  
  344.  
  345. REM  *** RastPort ausgeben ***
  346.  
  347. POKEW(ioRequest& + 28), command%
  348. POKEL(ioRequest& + 32), sRastPort&
  349. POKEL(ioRequest& + 36), sColorMap&
  350. POKEL(ioRequest& + 40), viewModes%
  351. POKEW(ioRequest& + 44), srcX%
  352. POKEW(ioRequest& + 46), srcY%
  353. POKEW(ioRequest& + 48), srcWidth%
  354. POKEW(ioRequest& + 50), srcHeight%
  355. POKEL(ioRequest& + 52), destCols&
  356. POKEL(ioRequest& + 56), destRows&
  357. POKEW(ioRequest& + 60), special%
  358.  
  359. ioError& = DoIO&(ioRequest&)
  360. IF ioError& <> 0 THEN
  361.    PRINT "DumpRPort Fehler =" ioError&
  362.    GOTO cleanup1
  363. END IF
  364.  
  365.  
  366. cleanup1:
  367.    REM  *** Close Printer Device ***
  368.    CALL CloseDevice(ioRequest&)
  369.  
  370. cleanup2:
  371.    REM  *** DeleteExtIO ***
  372.    POKE(ioRequest& + 8), &Hff
  373.    POKEL(ioRequest& + 20), -1
  374.    POKEL(ioRequest& + 24), -1
  375.    CALL FreeMem(ioRequest&,64)
  376.  
  377. cleanup3:
  378.    REM  *** DeletePort ***
  379.    CALL RemPort(msgPort&)
  380.    POKE(msgPort& + 8), &Hff  
  381.    POKEL(msgPort& + 20), -1
  382.    CALL FreeSignal(sigBit%)
  383.    CALL FreeMem(msgPort&,40)
  384.    
  385. cleanup4:   
  386.    LIBRARY CLOSE
  387.  
  388.  
  389. END      
  390. ende:
  391. WINDOW CLOSE 2:SCREEN CLOSE 2
  392. SYSTEM   
  393. END
  394.  '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  395.  '
  396.  'Detlef Kornatz
  397.  'Feuerbachstrasse 6
  398.  'D-4300 ESSEN 1
  399.  '
  400.  '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  401.